Software Vault: The Gold Collection/Software Vault - The Gold Collection (American Databankers) (1993).ISO/cdr06/winqueen.zip/QUEEN.PAS

Pascal/Delphi Source File | 1993-07-06 | 21KB | 658 lines

program QUEEN;

uses wintypes, winprocs, wobjects;
const
  appname : pchar = 'Queen';
var
  back : integer;
  face : array[1..10] of hbitmap;
type
  tmyapplication = object(tapplication)
    procedure initmainwindow; virtual;
  end;
  pdeckwindow = ^tdeckwindow;
  tdeckwindow = object(twindow)
    oldback, newback : integer;
    constructor init(aparent : pwindowsobject; aname : pchar);
    procedure frameit(dc : hdc);
    procedure paint(dc : hdc; var ps : tpaintstruct); virtual;
    procedure pressok(var msg : tmessage); virtual id_first + id_ok;
    procedure wmlbuttondown(var msg : tmessage); virtual wm_first + wm_lbuttondown;
  end;
  pqueenwindow = ^tqueenwindow;
  tqueenwindow = object(twindow)
    cardsize, newrect : trect;
    newgx, newgy, level : integer;
    move : array[1..3] of integer;
    buttondown, moved, fin : boolean;
    card : array[1..53] of hbitmap;
    dealt : array[1..52] of boolean;
    game : array[1..55] of record
      deck : 1..53;
      gx, gy : integer;
      row : 1..11;
      col : 1..24;
      canopen, canmove, opened, onscreen : boolean;
    end;
    pos : array[1..11, 1..24] of record
      num : 1..53;
      px, py : integer;
      rects : trect;
    end;
    constructor init(aparent : pwindowsobject; aname : pchar);
    procedure defcommandproc(var msg : tmessage); virtual;
    procedure drawbmp(dc : hdc; x, y : integer; size : trect; bitmap : hbitmap);
    function getclassname : pchar; virtual;
    procedure getwindowclass(var awndclass : twndclass); virtual;
    procedure moving;
    procedure newgame;
    procedure paint(dc : hdc; var ps : tpaintstruct); virtual;
    procedure setupwindow; virtual;
    procedure wmdestroy(var msg : tmessage); virtual wm_first + wm_destroy;
    procedure wmlbuttondown(var msg : tmessage); virtual wm_first + wm_lbuttondown;
    procedure wmlbuttonup(var msg : tmessage); virtual wm_first + wm_lbuttonup;
    procedure wmmousemove(var msg : tmessage); virtual wm_first + wm_mousemove;
    procedure wmrbuttondown(var msg : tmessage); virtual wm_first + wm_rbuttondown;
    procedure wmtimer(var msg : tmessage); virtual wm_first + wm_timer;
  end;

constructor tdeckwindow.init(aparent : pwindowsobject; aname : pchar);
var pbuttonok : pbutton;
begin
  twindow.init(aparent, aname);
  with attr do begin
    style := ws_caption or ws_visible;
    x := 100;  y := 100;
    w := 280;  h := 200;
  end;
  pbuttonok := new(pbutton, init(@self, id_ok, '&Ok', 110, 140, 60, 30, false));
  oldback := back;
  newback := back;
end;

procedure tdeckwindow.frameit(dc : hdc);
var i1, x, y : integer;
  pbrush : hbrush;
  rect : trect;
begin
  x := 20 + 50 * ((oldback - 1) mod 5);
  y := 10 + 64 * ((oldback - 1) div 5);
  setrect(rect, x, y, x + 40, y + 54);
  inflaterect(rect, 2, 2);
  pbrush := getstockobject(white_brush);
  for i1 := 1 to 3 do begin
    inflaterect(rect, 1, 1);
    framerect(dc, rect, pbrush);
  end;
  x := 20 + 50 * ((newback - 1) mod 5);
  y := 10 + 64 * ((newback - 1) div 5);
  setrect(rect, x, y, x + 40, y + 54);
  inflaterect(rect, 2, 2);
  pbrush := getstockobject(gray_brush);
  for i1 := 1 to 3 do begin
    inflaterect(rect, 1, 1);
    framerect(dc, rect, pbrush);
  end;
  oldback := newback;
end;

procedure tdeckwindow.paint(dc : hdc; var ps : tpaintstruct);
var i1, i2, x, y : integer;
  memdc : hdc;
begin
  memdc := createcompatibledc(dc);
  for i1 := 1 to 2 do
    for i2 := 1 to 5 do begin
      selectobject(memdc, face[i2 + 5 * (i1 - 1)]);
      x := 20 + 50 * (i2 - 1);
      y := 10 + 64 * (i1 - 1);
      stretchblt(dc, x, y, 40, 54, memdc, 0, 0, 71, 96, srccopy);
    end;
  frameit(dc);
  deletedc(memdc);
end;

procedure tdeckwindow.pressok(var msg : tmessage);
begin
  closewindow;
  if back <> oldback then begin
    back := oldback;
    with pqueenwindow(parent)^ do
      if not game[52].opened then card[53] := face[back];
    invalidaterect(hwindow, nil, true);
  end;
end;

procedure tdeckwindow.wmlbuttondown(var msg : tmessage);
var i1, i2, x, y : integer;
  rect : trect;
  dc : hdc;
begin
  for i1 := 1 to 2 do
    for i2 := 1 to 5 do begin
      x := 20 + 50 * (i2 - 1);
      y := 10 + 64 * (i1 - 1);
      setrect(rect, x, y, x + 40, y + 54);
      if ptinrect(rect, tpoint(msg.lparam)) then begin
        newback := i2 + 5 * (i1 - 1);
        if oldback <> newback then begin
          dc := getdc(hwindow);
          frameit(dc);
          releasedc(hwindow, dc);
        end;
      end;
    end;
end;

constructor tqueenwindow.init(aparent : pwindowsobject; aname : pchar);
begin
  twindow.init(aparent, appname);
  with attr do begin
    x := 40;  y := 30;
    w := 700; h := 500;
    style := ws_caption or ws_sysmenu or ws_minimizebox;
  end;
  buttondown := false;
  setrect(cardsize, 0, 0, 71, 96);
  move[3] := 0;
  level := 1;
  back := 1;
  messagebox(hwindow, '"addictions" vol.I - written by Steven', 'Queen', mb_ok);
  newgame;
end;

procedure tqueenwindow.defcommandproc(var msg : tmessage);
var pabout : pdialog;
  pdeck : pwindow;
  i1 : array[0..5] of char;
  newdeck : integer;
begin
  if msg.wparamhi = 0 then
    case msg.wparamlo of
      101 : newgame;
      102 : begin
        pdeck := new(pdeckwindow, init(@self, 'Select Card Back'));
        application^.makewindow(pdeck);
      end;
      103 : done;
      104 : begin
        new(pabout, init(@self, 'queenabout'));
        if application^.execdialog(pabout) = id_ok then application^.done;
      end;
      else twindow.defcommandproc(msg);
    end;
end;

procedure tqueenwindow.drawbmp(dc : hdc; x, y : integer; size : trect; bitmap : hbitmap);
var memdc : hdc;
  bm : tbitmap;
  madedc : boolean;
begin
  if dc = 0 then begin
    dc := getdc(hwindow);
    madedc := true;
  end
  else madedc := false;
  memdc := createcompatibledc(dc);
  selectobject(memdc, bitmap);
  with size do
    bitblt(dc, x, y, right - left, bottom - top, memdc, left, top, srccopy);
  deletedc(memdc);
  if madedc then releasedc(hwindow, dc);
end;

function tqueenwindow.getclassname;
begin
  getclassname := appname;
end;

procedure tqueenwindow.getwindowclass(var awndclass : twndclass);
begin
  twindow.getwindowclass(awndclass);
  awndclass.hicon := loadicon(hinstance, appname);
  attr.menu := loadmenu(hinstance, appname);
end;

procedure tqueenwindow.moving;
var i1, i2 : integer;
  dc, memdc : hdc;
  temp : array[1..2] of trect;
  temp2 : trect;
begin
  with game[move[3]] do begin
    dc := getdc(hwindow);
    memdc := createcompatibledc(dc);
    selectobject(memdc, card[deck]);
    setrect(newrect, newgx, newgy, newgx + 71, newgy + 96);
    if intersectrect(temp[1], newrect, pos[row, col].rects) = 0 then begin
      setrect(temp[1], gx, gy, gx + 71, gy + 96);
      setrect(temp[2], gx, gy, gx + 71, gy + 96);
    end
    else begin
      temp[2] := temp[1];
      if gx < newgx then begin
        temp[1].left := gx;
        temp[1].right := newgx;
        temp[2].left := gx;
      end;
      if gx > newgx then begin
        temp[1].left := newgx + 71;
        temp[1].right := gx + 71;
        temp[2].right := gx + 71;
      end;
      if gy < newgy then begin
        temp[2].top := gy;
        temp[2].bottom := newgy;
      end;
      if gy > newgy then begin
        temp[2].top := newgy + 96;
        temp[2].bottom := gy + 96;
      end;
      if not fin then begin
        if gx = newgx then temp[1].right := newgx;
        if gy = newgy then temp[2].bottom := newgy;
      end;
    end;
    for i2 := 1 to 2 do
      with temp[i2] do
        bitblt(dc, left, top, right - left, bottom - top, memdc, 0, 0, whiteness);
    deletedc(memdc);
    releasedc(hwindow, dc);
    for i1 := 1 to 53 do
      if (i1 <> move[3]) and game[i1].onscreen then
        if intersectrect(temp[1], pos[game[i1].row, game[i1].col].rects,
          pos[row, col].rects) <> 0 then begin
          temp[2] := temp[1];
          if (gx < newgx) and (newgx < temp[1].right) then
            temp[1].right := newgx;
          if (gx > newgx) and (newgx + 71 > temp[1].left) then
            temp[1].left := newgx + 71;
          if (gy < newgy) and (newgy < temp[2].bottom) then
            temp[2].bottom := newgy;
          if (gy > newgy) and (newgy + 96 > temp[2].top) then
            temp[2].top := newgy + 96;
          if not fin then begin
            if gx = newgx then temp[1].right := newgx;
            if gy = newgy then temp[2].bottom := newgy;
          end;
          for i2 := 1 to 2 do begin
            offsetrect(temp[i2], - game[i1].gx, - game[i1].gy);
            if not game[i1].opened then
              drawbmp(dc, game[i1].gx + temp[i2].left, game[i1].gy +
              temp[i2].top, temp[i2], face[back])
            else drawbmp(dc, game[i1].gx + temp[i2].left, game[i1].gy +
              temp[i2].top, temp[i2], card[game[i1].deck]);
          end;
        end;
  end;
end;

procedure tqueenwindow.newgame;
var i1, ran : 1..53;
  ro, co : integer;
begin
  i1 := 1;
  for ro := 1 to 7 do
    for co := 1 to ro do
      with game[i1] do begin
        row := ro;  col := co;
        with pos[row, col] do begin
          num := i1;
          px := round(350 - 76 * (row / 2 - col + 1));
          py := (ro - 1) * 30 + 10;
          gx := px;  gy := py;
          setrect(rects, px, py, px + 71, py + 96);
        end;
        i1 := i1 + 1;
      end;
  with game[53] do begin
    row := 10;  col := 10;  gx := 15;  gy := 310;  deck := 53;
    with pos[row, col] do begin
      px := gx;  py := gy;  num := 53;
      setrect(pos[row, col].rects, px, py, px + 71, py + 96);
    end;
  end;
  randomize;
  game[1].deck := 38;
  game[1].canopen := true;
  game[1].opened := true;
  game[53].canopen := true;
  game[53].canmove := false;
  game[53].opened := true;
  game[53].onscreen := true;
  for i1 := 1 to 52 do begin
    dealt[i1] := false;
    game[i1].canmove := false;
    game[i1].onscreen := true;
    if i1 > 28 then game[i1].onscreen := false;
  end;
  dealt[38] := true;
  for i1 := 2 to 52 do begin
    repeat
      ran := random(52) + 1
    until dealt[ran] = false;
    game[i1].deck := ran;
    game[i1].canopen := false;
    game[i1].opened := false;
    dealt[ran] := true;
  end;
  for i1 := 22 to 28 do begin
    game[i1].canopen := true;
    game[i1].canmove := true;
    game[i1].opened := true;
  end;
  card[53] := loadbitmap(hinstance, pchar(back + 52));
  invalidaterect(hwindow, nil, true);
  for i1 := 29 to 52 do
    with game[i1] do begin
      row := 11;  col := i1 - 28;
      with pos[row, col] do begin
        num := i1;
        px := round(500 / 23 * (col - 1)) + 100;
        py := 310;
        gx := px;  gy := py;
        setrect(pos[row, col].rects, px, py, px + 71, py + 96);
      end;
    end;
end;

procedure tqueenwindow.paint(dc : hdc; var ps : tpaintstruct);
var i1 : 1..53;
begin
  for i1 := 1 to 53 do
    with game[i1] do
      if onscreen then begin
        if not opened then drawbmp(dc, gx, gy, cardsize, face[back])
        else drawbmp(dc, gx, gy, cardsize, card[deck]);
      end;
end;

procedure tqueenwindow.setupwindow;
var i1 : 1..52;
begin
  twindow.setupwindow;
  for i1 := 1 to 52 do
    card[i1] := loadbitmap(hinstance, pchar(i1));
  for i1 := 1 to 10 do
    face[i1] := loadbitmap(hinstance, pchar(i1 + 52));
  card[53] := face[back];
end;

procedure tqueenwindow.wmdestroy(var msg : tmessage);
var i1 : 1..53;
begin
  for i1 := 1 to 53 do
    deleteobject(card[i1]);
  for i1 := 1 to 10 do
    deleteobject(face[i1]);
  twindow.wmdestroy(msg);
end;

procedure tqueenwindow.wmlbuttondown(var msg : tmessage);
var i1, co : 1..53;
  temp : trect;
begin
  if not game[1].onscreen then begin
    buttondown := true;
    killtimer(hwindow, 1);
    for i1 := 1 to 53 do
      game[i1].onscreen := false;
    invalidaterect(hwindow, nil, true);
    level := level + 1;
    if messagebox(hwindow, 'Do you want another one ?', 'You did it !',
      mb_yesno or mb_iconexclamation) = id_yes then newgame
    else done;
  end;
  if not buttondown then begin
    fin := false;
    move[3] := 0;
    for i1 := 1 to 53 do begin
      with game[i1] do
        if ptinrect(pos[row, col].rects, tpoint(msg.lparam)) and onscreen then
          move[3] := i1;
    end;
    if move[3] = 53 then buttondown := true;
    if move[3] <> 0 then
      with game[move[3]] do begin
        move[1] := msg.lparamlo - gx;
        move[2] := msg.lparamhi - gy;
        setrect(temp, gx, gy, gx + 71, gy + 96);
        if opened and ((Deck mod 13) = 0) then begin
          buttondown := true;
          onscreen := false;
        end;
        if (canopen and not opened) and (move[3] < 29) then begin
          opened := true;
          buttondown := true;
        end;
      end;
  end;
end;

procedure tqueenwindow.wmlbuttonup(var msg : tmessage);
var i1, ro, co : 1..52;
  temp : trect;
  only1, cancel, head, tail : integer;
  cancancel : boolean;
begin
  if buttondown and (move[3] <> 0) then begin
    if move[3] = 53 then begin
      if not game[52].opened then begin
        i1 := 28;
        repeat
          i1 := i1 + 1;
          with game[i1] do
            if not opened then begin
              canopen := true;
              opened := true;
              canmove := true;
              onscreen := true;
              invalidaterect(hwindow, @pos[row, col].rects, true);
              i1 := 52;
            end;
        until i1 > 51;
      end;
      if game[52].opened then begin
        card[53] := loadbitmap(hinstance, pchar(63));
        invalidaterect(hwindow, @pos[10, 10].rects, true);
      end;
    end
    else with game[move[3]] do begin
      only1 := 0;
      newgx := gx;  newgy := gy;
      fin := true;
      moving;
      if moved then begin
        for i1 := 1 to 52 do
          if intersectrect(temp, pos[game[i1].row, game[i1].col].rects,
            pos[row, col].rects) <> 0 then
            if ((deck mod 13) + (game[i1].deck mod 13)) = 13 then
              with game[i1] do begin
                if i1 = 1 then begin
                  if (move[3] = 2) and not game[3].onscreen then
                    game[1].canmove := true;
                  if (move[3] = 3) and not game[2].onscreen then
                    game[1].canmove := true;
                end;
                if opened and onscreen then begin
                  if canmove then begin
                    only1 := only1 + 1;
                    cancel := i1;
                  end
                  else if (move[3] > 28) and (i1 > 28) then begin
                    cancancel := true;
                    if abs(i1 - move[3]) = 1 then begin
                      only1 := only1 + 1;
                      cancel := i1;
                    end
                    else begin
                      for co := 1 to abs(i1 - move[3]) - 1 do begin
                        if (i1 > move[3]) and game[move[3] + co].onscreen then
                          cancancel := false;
                        if (i1 < move[3]) and game [i1 + co].onscreen then
                          cancancel := false;
                      end;
                      if cancancel then begin
                        only1 := only1 + 1;
                        cancel := i1;
                      end;
                    end;
                  end;
                end;
              end;
        if only1 = 1 then with game[cancel] do begin
          onscreen := false;
          game[move[3]].onscreen := false;
          invalidaterect(hwindow, @pos[row, col].rects, true);
        end;
      end;
      for ro := 1 to 6 do
        for co := 1 to ro do
          if (not game[pos[ro + 1, co].num].onscreen) and (not game[pos[ro + 1,
            co + 1].num].onscreen) then
            with game[pos[ro, co].num] do begin
              canopen := true;
              canmove := true;
            end;
      gx := pos[row, col].px;  gy := pos[row, col].py;
      newgx := gx;  newgy := gy;
      setrect(pos[row, col].rects, gx, gy, gx + 71, gy + 96);
      if only1 <> 1 then invalidaterect(hwindow, @pos[row, col].rects, true);
    end;
  end;
  head := 1;
  tail := 29;
  for i1 := 29 to 52 do begin
    game[i1].canmove := false;
    if game[i1].onscreen and (head = 1) then head := i1;
    if game[i1].onscreen and game[i1].opened then tail := i1;
  end;
  if head = 1 then head := 29;
  game[head].canmove := true;
  game[tail].canmove := true;
  i1 := 1;
  repeat
    tail := 1;
    with pos[11, i1] do
      if not game[num].onscreen and game[num].opened then begin
        game[55] := game[num];
        head := i1;
        repeat
          with pos[11, head + 1] do begin
            game[54] := game[num];
            game[num].gx := game[55].gx;
            game[num].gy := game[55].gy;
            game[num].col := game[55].col;
            pos[11, head].num := num;
            game[55] := game[54];
            if (head = 1) and game[pos[11, 1].num].onscreen then
              invalidaterect(hwindow, @pos[11, 1].rects, true);
            if game[num].onscreen then invalidaterect(hwindow, @rects, true);
          end;
          head := head + 1;
        until (pos[11, head].num > 51) or (head > 23);
        if (i1 = 1) and not game[num].onscreen then tail := 0;
        if (i1 > 1) and not game[52].opened then tail := 0;
      end;
    i1 := i1 + tail;
  until (i1 > 22) or (pos[11, i1].num = 52);
  if not game[1].onscreen then begin
    if move[3] = 1 then move[1] := cancel
    else move[1] := move[3];
    if settimer(hwindow, 1, 1, nil) = 0 then begin
      messagebox(hwindow, 'No timers left !', 'Error', mb_ok);
      halt(1);
    end;
  end;
  move[3] := 0;
  buttondown := false;
  moved := false;
end;

procedure tqueenwindow.wmmousemove(var msg : tmessage);
var x, y, head, tail : integer;
begin
  if move[3] <> 0 then
    with game[move[3]] do
      if canmove then begin
        buttondown := true;
        moved := true;
        x := msg.lparamlo - gx - move[1];
        y := msg.lparamhi - gy - move[2];
        newgx := gx + x;  newgy := gy + y;
        moving;
        offsetrect(pos[row, col].rects, x, y);
        gx := newgx;  gy := newgy;
        drawbmp(0, gx, gy, cardsize, card[deck]);
      end;
end;

procedure tqueenwindow.wmrbuttondown(var msg : tmessage);
var i1 : integer;
begin
  if not game[1].onscreen then begin
    killtimer(hwindow, 1);
    for i1 := 1 to 53 do
      game[i1].onscreen := false;
    invalidaterect(hwindow, nil, true);
    level := level + 1;
    if messagebox(hwindow, 'Do you want another one ?', 'You did it !',
      mb_yesno or mb_iconexclamation) = id_yes then newgame
    else done;
  end
  else newgame;
end;

procedure tqueenwindow.wmtimer(var msg : tmessage);
var i1, x, y : integer;
  angle : real;
  procedure chase(i2, x, y :integer);
  begin
    with game[i2] do begin
      if (gx < 5) or (gx > 625) then canopen := not canopen;
      if canopen then gx := gx - 5 * x
      else gx := gx + 5 * x;
      if (gy < 5) or (gy > 375) then canmove := not canmove;
      if canmove then gy := gy - 5 * x
      else gy := gy + 5 * x;
      drawbmp(0, gx, gy, cardsize, card[deck]);
    end;
  end;
begin
  if level = 4 then level := 1;
  case level of
    1 : for i1 := 1 to 50 do begin
      chase(1, 1, 1);
      chase(move[1], 1, 1);
    end;
    2 : for i1 := 1 to 50 do begin
      x := random(21) * 35;
      y := random(11) * 48;
      case random(3) of
        0 : drawbmp(0, x, y, cardsize, card[38]);
        1 : drawbmp(0, x, y, cardsize, card[game[move[1]].deck]);
        2, 3 : drawbmp(0, x, y, cardsize, face[back]);
      end;
    end;
    3 : for i1 := 0 to 72 do begin
      angle := i1 * pi /36;
      x := round(cos(angle) * (1 - sin(angle)) * 150);
      y := 47 - round(sin(angle) * (1 - sin(angle)) * 150);
      drawbmp(0, 315 + x, y, cardsize, card[38]);
      drawbmp(0, 315 - x, y, cardsize, card[game[move[1]].deck]);
    end;
  end;
end;

procedure tmyapplication.initmainwindow;
begin
  mainwindow := new(pqueenwindow, init(nil, appname));
end;

var myapp : tmyapplication;
begin
  myapp.init(appname);
  myapp.run;
  myapp.done;
end.